perm filename EXPR.SAI[PNT,HE]22 blob
sn#506181 filedate 1980-04-19 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 ENTRY
C00005 00003 ! miscellaneous definitions
C00010 00004 ! expression builders: exp,bfact,bterm,aexp,term,factor,pfactor
C00017 00005 ! expression builders: hash,hashindex,new_expr,check_expr
C00019 00006 ! expression builders: opcode, idcode, cncode,arcode,prcode
C00031 00007 ! mkexpr,gtexpr,aref,idref,pref
C00035 00008 ! buffer definitions, ipush,fpush,gpush,ppush,cpush
C00037 00009 ! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off
C00043 00010 ! $append,$aappend
C00048 00011 ! $$gtidref,$$gtanyexp
C00051 00012 ! $$gtexpr,$$gtvexpr
C00052 ENDMK
C⊗;
ENTRY;
BEGIN "EXPR"
DEFINE $$PRGID=TRUE; DEFINE $EXPR=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
REQUIRE "[][]" DELIMITERS;
DEFINE TOKEN_INDEX = [TOKENINDEX],TOKEN_CLASS=[tokenclass],ID_CLASS=[TOKEN_INDEX];
REAL PROCEDURE SIMPLIFY(INTEGER OP;REAL F1,F2);
BEGIN "simplifies binary operations on scalar constants "
INTEGER I1,I2,B1,B2; REAL F3;
I1←F1; I2←F2;
B1←IF F1 THEN 1 ELSE 0;
B2←IF F2 THEN 1 ELSE 0;
CASE OP OF
BEGIN
REDEFINE ZZ(ARG0,ARG1,ARG2,EX)=[;];
REDEFINE ZZC(ARG0,ARG1,ARG2,EX)=[;EX];
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[];
OP_LIST
END;
RETURN(F3);
END;
REDEFINE ZZ(ACR0,ARG1,ARG2,EX)=[FALSE,];
REDEFINE ZZC(ARG0,ARG1,ARG2,EX)=[TRUE,];
preload_array(COMPILEEXPRESSION, OP_LIST,BOOLEAN, 1, #PNTINTOPS);
! will be moved to SYMBOL;
RPTR(EXPR$)PROCEDURE MK_EXPR$;
BEGIN
RPTR(EXPR$)EE;
EE←NEW_RECORD(EXPR$);
if !debug and ¬!!debugging then EXPR$:DBEXPR[ee]←NEW_RECORD(DBEXPR);
RETURN(EE);
END;
! miscellaneous definitions ;
PRELOAD_WITH "SCALAR","VECTOR","ROT","TRANS","FRAME","EVENT";
STRING ARRAY DTYPES[1:6];
COMMENT TEMPORARY EXPR RECORD USED INTERNALLY BY THESE ROUTINES;
RCLASS !!EXPR(INTEGER OP,X1,X2; INTEGER TYPE,#EL; RPTR(!!EXPR)SON,BRO;
BOOLEAN CONST; REAL RLVAL; RPTR(EXPR$)EXPR$);
! OP is opcode, x1,x2 are used to represent floating point numbers in 11 format
x1 along is used for index of array
x2 is used for leveloffset of array
const is true if the value is a constant
expr$ is used (particularly in QUERY) to store record EXPR$;
INTEGER ##EL;
INTEGER BRCHAR,SPBR;
REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG0,] ;
REDEFINE ZZC(ARG0,ARG1,ARG2)=[ARG0,] ;
preload_array(CODE_OP, OP_LIST,STRING, 1, #PNTINTOPS);
REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG2,];
REDEFINE ZZC(ARG0,ARG1,ARG2)=[ARG2,];
preload_array(CODE_LEVEL,OP_LIST,INTEGER,1,#PNTINTOPS);
REDEFINE XXCOUNT=0;
REDEFINE ZZ(ARG1,ARG2,ARG3)=[];
REDEFINE ZZC(ARG1,ARG2,ARG3)=[];
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
REDEFINE XXCOUNT=XXCOUNT + 1;];
OP_LIST;
DEFINE XXARG=0;
REDEFINE ZZ(ARG1,ARG2,ARG3)=[ REDEFINE XXARG=XXARG + 1;];
REDEFINE ZZC(ARG1,ARG2,ARG3)=[ REDEFINE XXARG=XXARG + 1;];
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
REDEFINE XXVAL = ((((XXARG*#DTYPE)+ARG1)*#DTYPE+ARG2)*#DTYPE+ARG3);
XXVAL,
];
DEFINE #HASHTAB=XXCOUNT;
preload_array(HASHTAB, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,AR2,ARG)=[
IFCR ¬DECLARATION(ARGNAME) THENC
REQUIRE "UNDEFINED OP:: "&CVPS(ARGNAME)&"
" MESSAGE;
ENDC];
OP_LIST;
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
IFCR ¬DECLARATION(ARGNAME) THENC
MAKEOP(ARGNAME)
ENDC ARGNAME,];
preload_array(PCODE, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[ARGNDX,];
preload_array(PCODENDX, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[ARGTYPE,];
preload_array(OPTYPE, OP_LIST, INTEGER, 1, #HASHTAB);
PROCEDURE GGTOKEN(BOOLEAN FLAG(TRUE));
α INTEGER I;
GTOKEN(FLAG);
FOR I←1 STEP 1 UNTIL #PNTINTOPS
DO IF EQU(TOKEN,CODE_OP[I])
THEN BEGIN
#TOKEN←OPERATOR_TYPE;
TOKEN_CLASS←CODE_LEVEL[I];
TOKEN_INDEX←I;
RETURN;
END;
IF EQU(TOKEN,0) THEN #TOKEN←UNDECLARED_TYPE;
β;
FORWARD RPTR (!!EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(!!EXPR)EPTR;
RPTR(EXPR$)EEPTR(NULL_RECORD));
FORWARD RPTR (!!EXPR) PROCEDURE CNCODE(REAL VAL);
FORWARD RPTR (!!EXPR) PROCEDURE IDCODE(RPTR(SYMBOL)SYMPTR);
FORWARD RECURSIVE RPTR (!!EXPR) PROCEDURE ARCODE(RPTR(SYMBOL)PTR;INTEGER OPERATION(XGTVAL));
FORWARD RECURSIVE RPTR(!!EXPR)PROCEDURE VPRCODE(RPTR(SYMBOL)PRSYM);
! expression builders: exp,bfact,bterm,aexp,term,factor,pfactor;
! EXP E: BF { OR BF }
BFACT BF: BT { AND BT }
BTERM BT: AE | AE <REL> AE
AEXP AE: {+|-} T {+|- T }
TERM T: F {*|/ F}
FACTOR F: PF or PF↑PF
PFACTOR PF: ( E ) or | E | or func(E,E,E,..) or <constant> or <id> or ¬ PF;
DEFINE EXP= [XXXXX(EXP_XX)];
! FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE EXP XXXXX(EXP_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BEFACT XXXXX(BEFACT_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BFACT XXXXX(BFACT_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BTERM XXXXX(BTERM_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE AEXP XXXXX(AEXP_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE TERM XXXXX(TERM_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE FACTOR XXXXX(FACTOR_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE PF XXXXX(PF_XX);
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE XXXXX(INTEGER LEVEL);
RECURSIVE RPTR(!!EXPR) PROCEDURE OP1(INTEGER LVL);
α INTEGER I; I←TOKEN_INDEX; GGTOKEN;
RETURN(OPCODE(I,1,XXXXX(LVL)));
β;
RECURSIVE RPTR(!!EXPR)PROCEDURE OP2(INTEGER LVL;RPTR(!!EXPR)E);
α INTEGER I; I←TOKEN_INDEX; GGTOKEN;
!!EXPR:BRO[E]←XXXXX(LVL);
RETURN(OPCODE(I,2,E));
β;
RECURSIVE RPTR(!!EXPR) PROCEDURE XXXXX(INTEGER LEVEL);
α RPTR(!!EXPR)$$1,$$2,$$3; INTEGER I,I2;
CASE LEVEL OF
α
[BEFACT_XX] [BFACT_XX] [AEXP_XX] [TERM_XX]
α
IF LEVEL=AEXP_XX AND #TOKEN=OPERATOR_TYPE
AND TOKEN_CLASS= AEXP_XX
THEN $$1←OP1(LEVEL + 1)
ELSE $$1←XXXXX(LEVEL+1);
WHILE #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS=LEVEL DO
$$1←OP2(LEVEL+1,$$1);
β;
[EXP_XX] [BTERM_XX] [FACTOR_XX]
α
$$1←XXXXX(LEVEL + 1);
IF (#TOKEN=OPERATOR_TYPE OR #TOKEN=RES_TYPE) AND TOKEN_CLASS=LEVEL
THEN $$1←OP2(LEVEL+1,$$1);
β;
[PF_XX]
CASE #TOKEN OF
α "CASE #TOKEN"
[REAL_TYPE] [INT_TYPE]
α INTEGER I;
$$1←CNCODE(REALSCAN(TOKEN,I)); GGTOKEN(FALSE); β;
[ID_TYPE]
α CASE SYMBOL:ACCESS[TOKENPTR] OF
α
[#SIMPLE] $$1←IDCODE(TOKENPTR);
[#ARRAY] $$1←ARCODE(TOKENPTR);
[#PROCEDURE] $$1←VPRCODE(TOKENPTR)
β;
GGTOKEN(FALSE);
β ;
[OPERATOR_TYPE]
CASE TOKEN_INDEX OF
α "CASE TOKEN_INDEX"
[LPAREN_X]
α "LPAREN_X"
GGTOKEN; $$2←$$1←EXP; I2←1;
IF TOKEN≠")"
THEN WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP;
I2←I2+1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")" THEN
ERROR("MISMATCHED PAREN")
ELSE GGTOKEN(FALSE);
IF I2≠1 THEN $$1←OPCODE(IMPLICIT_X,I2,$$1);
β "LPAREN_X";
[MAGNITUDE_X]
α GGTOKEN; $$1←EXP;
IF TOKEN="|"
THEN GGTOKEN(FALSE)
ELSE ERROR("MISMATCHED VERT BAR");
$$1←OPCODE(MAGNITUDE_X,1,$$1);
β;
[STOS_X][DOWNARROW_X][DOLLAR_X][ALPHA_X]
$$1←OP1(EXP_XX);
[INSCALAR_X]
α
$$1←OPCODE(TOKEN_INDEX,0,NULL_RECORD);
GGTOKEN(FALSE);
β;
[QQUERY_X]
α
$$1←OPCODE(TOKEN_INDEX,0,NULL_RECORD,PRINTCODE);
GGTOKEN(FALSE);
β;
ELSE
α I←TOKEN_INDEX; IF TOKEN_CLASS≠LEVEL
THEN ERROR(TOKEN&" is not a valid term in an expression");
IF I=RUNTIME_X THEN
α GGTOKEN(FALSE);
IF TOKEN≠"(" THEN RETURN($$1←OPCODE(I,1,CNCODE(0.0)))
ELSE STOKEN←TRUE;
β;
WORD_READ("(");
GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")" THEN ERROR("MISMATCHED PAREN") ELSE GGTOKEN(FALSE);
$$1←OPCODE(I,I2,$$1);
β
β "CASE TOKEN_INDEX";
[RES_TYPE]
α I←TOKEN_INDEX; IF TOKEN_CLASS≠LEVEL
THEN ERROR(TOKEN&" is not a valid term in an expression");
WORD_READ("("); GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")"
THEN ERROR("MISMATCHED PAREN")
ELSE GGTOKEN(FALSE);
$$1←OPCODE(I,I2,$$1);
β;
ELSE α ERROR("UNEXPECTED TOKEN FOUND ⊂"&TOKEN&"⊃");
$$1←NEW_RECORD(!!EXPR);
β
β "CASE #TOKEN"
β;
RETURN($$1);
β;
! expression builders: hash,hashindex,new_expr,check_expr;
INTEGER PROCEDURE HASH(INTEGER OP; INTEGER ARRAY IX);
RETURN((((OP*#DTYPE + IX[1])*#DTYPE+IX[2])*#DTYPE +IX[3]));
INTEGER PROCEDURE HASHINDEX(INTEGER HASHVAL);
BEGIN
INTEGER INDEX,LB,UB;
LB←1;UB←#HASHTAB;
DO BEGIN
INDEX←(LB+UB)/2;
IF HASHTAB[INDEX]=HASHVAL THEN RETURN(INDEX)
ELSE IF HASHTAB[INDEX]>HASHVAL THEN UB←INDEX-1
ELSE LB←INDEX+1;
END UNTIL LB>UB;
RETURN(0);
END;
RPTR (!!EXPR) PROCEDURE NEW_EXPR(INTEGER OP; RPTR(!!EXPR) SON(NULL_RECORD),
BRO(NULL_RECORD),SELF(NULL_RECORD));
BEGIN
RPTR (!!EXPR) CUR;
IF SELF=NULL_RECORD THEN CUR←NEW_RECORD(!!EXPR) ELSE CUR←SELF;
!!EXPR:OP[CUR]←OP;
!!EXPR:SON[CUR]←SON;
!!EXPR:BRO[CUR]←BRO;
##EL←##EL + (!!EXPR:#EL[CUR]←1);
RETURN(CUR);
END;
INTEGER PROCEDURE CHECK_EXPR(INTEGER OP,NARGS; RPTR(!!EXPR)ARRAY EXPRRY);
BEGIN
COMMENT EXPPRY WILL BE OF SIZE [1:NARGS];
INTEGER I;
INTEGER ARRAY IX[1:3];
IF NARGS>3 THEN ERROR("More arguments for function "&CODE_OP[OP]&" than allowed");
ARRCLR(IX);
FOR I←1 STEP 1 UNTIL NARGS DO IX[I]←!!EXPR:TYPE[EXPRRY[I]];
I←HASHINDEX(HASH(OP,IX));
RETURN(I);
END;
! expression builders: opcode, idcode, cncode,arcode,prcode;
RPTR (!!EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(!!EXPR)EPTR;
RPTR(EXPR$)EEPTR(NULL_RECORD));
BEGIN
RPTR(!!EXPR)ARRAY EXPRRY[0:NARGS]; ! 0 in case NARGS=0 ;
RPTR(!!EXPR) P1,P2;
INTEGER I;INTEGER PCODE_INDEX;
P1←EPTR;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN
EXPRRY[I]←P1;
P1←!!EXPR:BRO[P1];
END;
IF P1≠NULL_RECORD THEN ERROR("P1 should be null record");
IF (PCODE_INDEX←CHECK_EXPR(OP,NARGS,EXPRRY))=0
THEN BEGIN
STRING S; S←NULL;
FOR I←1 STEP 1 UNTIL NARGS DO
S←S&" "&DTYPES[!!EXPR:TYPE[EXPRRY[I]]]&",";
ERROR("operator/function "&CODE_OP[OP]&" cannot take operand(s)"&S[1 to ∞-1]);
END;
IF NOT !NOFOLD AND COMPILEEXPRESSION[OP] THEN
BEGIN "constant folding"
IF NARGS=2 AND OPTYPE[PCODE_INDEX]=#SC AND
!!EXPR:CONST[EXPRRY[1]] AND !!EXPR:CONST[EXPRRY[2]]
THEN BEGIN "constant arguments"
REAL R;
##EL←##EL-6; ! we are going to not use 2 records ;
R←SIMPLIFY(OP,!!EXPR:RLVAL[EXPRRY[1]],!!EXPR:RLVAL[EXPRRY[2]]);
P1←CNCODE(R);
RETURN(P1);
END
ELSE IF NARGS=1 AND OPTYPE[PCODE_INDEX]=#SC AND !!EXPR:CONST[EXPRRY[1]]
THEN BEGIN
REAL R;
##EL←##EL-3;
R←SIMPLIFY(OP,0.0,!!EXPR:RLVAL[EXPRRY[1]]);
P1←CNCODE(R);
RETURN(P1);
END;
END;
P1←NEW_RECORD(!!EXPR);
IF PCODENDX[PCODE_INDEX]
THEN BEGIN I←2; !!EXPR:X1[P1]←PCODENDX[PCODE_INDEX]; END
ELSE I←1;
##EL←##EL + (!!EXPR:#EL[P1]←I);
!!EXPR:OP[P1]←PCODE[PCODE_INDEX];
!!EXPR:TYPE[P1]←OPTYPE[PCODE_INDEX];
!!EXPR:SON[P1]←EPTR;
IF (!!EXPR:EXPR$[P1]←EEPTR) THEN ##EL←##EL+EXPR$:#BODY[EEPTR];
RETURN(P1);
END;
RPTR (!!EXPR) PROCEDURE CNCODE(REAL VAL);
BEGIN "cncode"
COMMENT CODE TO HANDLE CONSTANTS;
RPTR(!!EXPR)E1;
E1←NEW_RECORD(!!EXPR);
##EL←##EL + (!!EXPR:#EL[E1]←3);
!!EXPR:TYPE[E1]←#SC;
!!EXPR:OP[E1]←XPUSHSCI;
FLTOUT(VAL,!!EXPR:X1[E1],!!EXPR:X2[E1]);
!!EXPR:CONST[E1]←TRUE;
!!EXPR:RLVAL[E1]←VAL;
RETURN(E1);
END "cncode";
RPTR (!!EXPR) PROCEDURE IDCODE(RPTR(SYMBOL)SYMPTR);
BEGIN
! COMMENT CHANGE ID_OFFSET PART WHEN WE CAN DETERMINE ID_OFFSET DIRECTLY;
RPTR(!!EXPR)E1;
E1←NEW_RECORD(!!EXPR);
IF SYMBOL:INDEX[SYMPTR]>0 THEN
BEGIN "simply defined"
##EL←##EL + (!!EXPR:#EL[E1]←3);
!!EXPR:OP[E1]←XAGTVAL;
!!EXPR:X1[E1]←SYMBOL:INDEX[SYMPTR];
!!EXPR:X2[E1]←SYMBOL:OFFSET[SYMPTR];
END
ELSE BEGIN "for nonsimple symbols"
##EL←##EL+(!!EXPR:#EL[E1]←2);
!!EXPR:OP[E1]←XGTVAL;
!!EXPR:X1[E1]←SYMBOL:OFFSET[SYMPTR];
END;
!!EXPR:TYPE[E1]←SYMBOL:TYPE[SYMPTR];
RETURN(E1);
END;
RPTR(!!EXPR)PROCEDURE IDNDXCODE(RPTR(SYMBOL)PTR);
IF SYMBOL:INDEX[PTR]>0
THEN BEGIN RPTR(!!EXPR) E1;
E1←NEW_RECORD(!!EXPR);
!!EXPR:OP[E1]←XPUSHINTI;
!!EXPR:X1[E1]←SYMBOL:INDEX[PTR];
##EL←##EL+(!!EXPR:#EL[E1]←2);
RETURN(E1);
END
ELSE RETURN(NEW_EXPR(XNOOP));
RECURSIVE RPTR(!!EXPR)PROCEDURE ARNDXCODE(RPTR(SYMBOL)PTR);
BEGIN
! This procedure produces the tree form for the array
reference index. To get the full array reference
use arcode with the right argument GTVAL or CHNGE;
RPTR(!!EXPR)E2,E3;
INTEGER I;
GGTOKEN;
IF TOKEN≠"[" THEN ERROR("Need [ after array name");
GGTOKEN;
E2←EXP;
IF (E2=NULL_RECORD) OR (!!EXPR:TYPE[E2]≠#SC)
THEN ERROR("Index of Array must be scalar");
FOR I←2 STEP 1 UNTIL ARRAYREC:#DIM[SYMBOL:OBJECT[PTR]] DO
BEGIN
IF TOKEN≠"," THEN ERROR("Need comma between fields of array index");
GTOKEN;
IF ((E3←EXP)=NULL_RECORD) OR (!!EXPR:TYPE[E3]≠#SC)
THEN ERROR("Index of Array must be scalar");
!!EXPR:BRO[E3]←E2;
E2←E3;
END;
IF TOKEN≠"]" THEN ERROR("Need ] for bounds of array");
RETURN(E2);
END;
RECURSIVE RPTR(!!EXPR)PROCEDURE ARCODE(RPTR(SYMBOL)PTR; INTEGER OPERATION(XGTVAL));
BEGIN
RPTR(!!EXPR)E1;
IF (OPERATION≠XGTVAL) AND (OPERATION≠XCHNGE)
THEN ERROR("Error in ARCODE, OPERATION can take only XGTVAL or XCHNGE");
E1←NEW_RECORD(!!EXPR);
!!EXPR:OP[E1]←OPERATION;
!!EXPR:X1[E1]←SYMBOL:OFFSET[PTR];
!!EXPR:TYPE[E1]←SYMBOL:TYPE[PTR];
##EL←##EL+(!!EXPR:#EL[E1]←2);
!!EXPR:SON[E1]←ARNDXCODE(PTR);
RETURN(E1);
END;
RPTR(!!EXPR)PROCEDURE SPRCODE(RPTR(SYMBOL)PRSYM);
BEGIN
RPTR(!!EXPR)E1;
E1←NEW_RECORD(!!EXPR);
!!EXPR:OP[E1]←XPROC;
!!EXPR:X1[E1]←SYMBOL:OFFSET[PRSYM];
##EL←##EL+(!!EXPR:#EL[E1]←2);
RETURN(E1);
END;
RECURSIVE RPTR(!!EXPR)PROCEDURE PRCODE(RPTR(SYMBOL)PRSYM);
BEGIN "prcode"
INTEGER NARGS; RPTR(PROC)P;
RPTR(!!EXPR)EF;
NARGS←PROC:NARGS[P←SYMBOL:OBJECT[PRSYM]];
IF NARGS =0 THEN EF←SPRCODE(PRSYM)
ELSE BEGIN "procedure with arguments"
! E1,ETOP1 are pointers to the procedure call,
E0 refers to the arguments set up if they are values ;
RPTR(!!EXPR)E0,E1,ETOP1,ETMP,ETMP2; INTEGER I;
GGTOKEN;
IF TOKEN≠"(" THEN ERROR("Need open paren after procedure name "&SYMBOL:PNAME[PRSYM]);
ETOP1←E1←SPRCODE(PRSYM);
E0←NULL_RECORD;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN "check each argument"
GGTOKEN;
IF PROC:ARGACCS[P][I] LAND #ARRTYP THEN
BEGIN "array argument found"
IF TOKENPTR=NULL_RECORD
THEN ERROR("Need array reference here")
ELSE IF SYMBOL:ACCESS[TOKENPTR]≠#ARRAY
THEN ERROR("Need array reference here")
ELSE IF ARRAYREC:#DIM[SYMBOL:OBJECT[TOKENPTR]]
≠PROC:ARGDIM[P][I]
THEN ERROR("array dimensions dont agree with declaration");
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(SYMBOL:OFFSET[TOKENPTR]));
E1←ETMP;
END "array argument found"
ELSE BEGIN
ETMP←EXP;
IF NOT(!!EXPR:TYPE[ETMP] LAND PROC:ARGTYPE[P][I])
THEN ERROR("expression type does not agree with declaration");
IF (PROC:ARGACCS[P][I]=0) OR
(PROC:ARGACCS[P][I] LAND #REFTYP) AND
(!!EXPR:OP[ETMP]≠XAGTVAL) AND
(!!EXPR:OP[ETMP]≠XGTVAL)
THEN
BEGIN "value"
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(#MINUS1));
E1←ETMP; STOKEN←TRUE;
END "value"
ELSE BEGIN "reference"
IF !!EXPR:OP[ETMP]=XGTVAL THEN
BEGIN "xgtval"
ETMP2←NEW_EXPR(!!EXPR:X1[ETMP]);
!!EXPR:BRO[E1]←ETMP2;
E1←ETMP2;
ETMP←!!EXPR:SON[ETMP];
##EL←##EL-2;
IF ETMP THEN
BEGIN
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
END;
END "xgtval"
ELSE IF !!EXPR:OP[ETMP]=XAGTVAL
THEN
BEGIN "xagtval"
ETMP2←NEW_EXPR(!!EXPR:X2[ETMP]);
!!EXPR:BRO[E1]←ETMP2;
E1←ETMP2;
##EL←##EL-1;
!!EXPR:OP[ETMP]←XPUSHINTI;
!!EXPR:#EL[ETMP]←2;
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
END "xagtval"
ELSE ERROR("Disastrous error");
STOKEN←TRUE;
END "reference";
END;
GGTOKEN;
IF I<NARGS AND TOKEN≠"," THEN
BEGIN ERROR("Need comma between arguments"); GGTOKEN; END;
IF I=NARGS AND TOKEN≠")" THEN
ERROR("Need right paren after argument list");
END "check each argument";
EF←NEW_EXPR(XNOOP,NEW_EXPR(XNOOP,E0,ETOP1));
END "procedure with arguments";
!!EXPR:TYPE[EF]←SYMBOL:TYPE[PRSYM];
RETURN(EF);
END "prcode";
! checks that PRSYM points to a typed procedure ;
RECURSIVE RPTR(!!EXPR)PROCEDURE VPRCODE(RPTR(SYMBOL)PRSYM);
IF SYMBOL:TYPE[PRSYM]=#PR
THEN ERROR(SYMBOL:PNAME[PRSYM]&" cannot return a value and cannot be used here")
ELSE RETURN(PRCODE(PRSYM));
! mkexpr,gtexpr,aref,idref,pref;
RPTR(EXPR$) PROCEDURE MKEXPR(INTEGER BUFSIZ;RPTR(!!EXPR)EE);
BEGIN "MKEXPR"
! routine for changing the tree structure form of the expression into
an integer array.
The integer array is returned in EXPR$:BODY;
! Caution : the bro field of the expression EE should be null ;
INTEGER ARRAY BUFFER[1:BUFSIZ]; INTEGER Q; RPTR(EXPR$) $$;
PROCEDURE PUSHBUFFER(INTEGER I);
BUFFER[Q←Q+1]←I;
PROCEDURE PUSHARRAY(RPTR(EXPR$)EPTR);
IF EPTR THEN BEGIN
ARRBLT(BUFFER[Q+1],EXPR$:BODY[EPTR][1],EXPR$:#BODY[EPTR]);
Q←Q+EXPR$:#BODY[EPTR]; END;
RECURSIVE PROCEDURE REDUCE(RPTR(!!EXPR)E);
BEGIN
RPTR(!!EXPR)E1;
E1←!!EXPR:SON[E];
WHILE E1≠NULL_RECORD DO
BEGIN REDUCE(E1);
E1←!!EXPR:BRO[E1];
END;
PUSHARRAY(!!EXPR:EXPR$[E]);
PUSHBUFFER(!!EXPR:OP[E]);
IF !!EXPR:#EL[E]=1 THEN RETURN;
PUSHBUFFER(!!EXPR:X1[E]);
IF !!EXPR:#EL[E]=2 THEN RETURN;
PUSHBUFFER(!!EXPR:X2[E]);
END;
Q←0;
REDUCE(EE);
IF Q≠BUFSIZ THEN ERROR("something is wrong, the string of numbers"&CVS(Q)&" not equal to expected"&CVS(BUFSIZ));
RETURN(αEXPR$(BUFFER,!!EXPR:TYPE[EE]));
END "MKEXPR";
RPTR(EXPR$)RECURSIVE PROCEDURE GTEXPR;
BEGIN "GTEXPR"
! driver for MKEXPR;
RPTR(!!EXPR)EE;
INTEGER ##ELSAVE,#EL;
##ELSAVE←##EL;
##EL←0;
GGTOKEN;
EE←EXP;
STOKEN←TRUE;
#EL←##EL;
##EL←##ELSAVE;
RETURN(MKEXPR(#EL,EE));
END "GTEXPR";
INTERNAL RPTR(EXPR$)PROCEDURE AREF(RPTR(SYMBOL)S;INTEGER OPERATION(XGTVAL));
BEGIN "AREF"
RPTR(!!EXPR)EE;
##EL←0;
EE←ARCODE(S,OPERATION);
RETURN(MKEXPR(##EL,EE));
END "AREF";
INTERNAL RPTR(EXPR$)PROCEDURE PREF(RPTR(SYMBOL)S);
BEGIN
RPTR(!!EXPR)EE;
##EL←0;
EE←PRCODE(S);
RETURN(MKEXPR(##EL,EE));
END;
! produces the EXPR$ record for references to variables
i.e. code to push the desired offset onto the stack ;
INTERNAL RPTR(EXPR$)PROCEDURE IDREF(REFERENCE RPTR(SYMBOL)S);
BEGIN "IDREF"
RPTR(!!EXPR)EE;
GGTOKEN;
IF TOKENPTR=NULL_RECORD THEN ERROR("Need identifier here")
ELSE S←TOKENPTR;
##EL←0;
EE←EXP;
IF !!EXPR:OP[EE]=XGTVAL THEN !!EXPR:OP[EE]←XPUSHOFFSET
ELSE IF !!EXPR:OP[EE]=XAGTVAL THEN !!EXPR:OP[EE]←XAPUSHOFFSET
ELSE ERROR("Need an identifier or array element here");
STOKEN←TRUE;
RETURN(MKEXPR(##EL,EE));
END "IDREF";
! buffer definitions, ipush,fpush,gpush,ppush,cpush;
INTEGER ARRAY $BUFFER[1:200];
INTEGER $BUFFERPTR;
! pushes integer J into the buffer ;
INTERNAL SIMPLE PROCEDURE IPUSH(INTEGER J);
$BUFFER[$BUFFERPTR←$BUFFERPTR+1]←J;
! pushes 11 representation of real value R into buffer ;
INTERNAL SIMPLE PROCEDURE FPUSH(REAL R);
BEGIN
FLTOUT(R,$BUFFER[$BUFFERPTR+1],$BUFFER[$BUFFERPTR+2]);
$BUFFERPTR←$BUFFERPTR+2;
END;
! pushes code to do a gtval ;
INTERNAL PROCEDURE GPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XAGTVAL,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XGTVAL,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
INTERNAL PROCEDURE CPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XACHNGE,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XCHNGE,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
INTERNAL PROCEDURE PPUSH(RPTR(SYMBOL)S);
IF SYMBOL:INDEX[S]>0 THEN
BEGIN IPUSH(XPUSHINTI);IPUSH(SYMBOL:INDEX[S]); END;
! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off;
INTERNAL RPTR (EXPR$)PROCEDURE βEXPR$(INTEGER TYPE(0));
BEGIN
! creates a record EXPR$ with data from the buffer $BUFFER;
RPTR(EXPR$)EE; INTEGER ARRAY BUFF[1:$BUFFERPTR];
ARRBLT(BUFF[1],$BUFFER[1],$BUFFERPTR);
! EE←NEW_RECORD(EXPR$);
EE←MK_EXPR$;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←$BUFFERPTR;
EXPR$:TYPE[EE]←TYPE;
$BUFFERPTR←0;
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE NEXPR(INTEGER SIZE,ARG1);
BEGIN
! produces a record EXPR$ with #BODY=SIZE, and first element=ARG1;
INTEGER ARRAY BUFF[1:SIZE];
RPTR(EXPR$)EE;
BUFF[1]←ARG1;
! EE←NEW_RECORD(EXPR$);
EE←MK_EXPR$;
EXPR$:#BODY[EE]←SIZE;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$1(INTEGER I(0));
RETURN(NEXPR(1,I));
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$2(INTEGER I(0),J(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(2,I);
EXPR$:BODY[E][2]←J;
RETURN(E);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$3(INTEGER I(0),J(0),K(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(3,I);
EXPR$:BODY[E][2]←J;
EXPR$:BODY[E][3]←K;
RETURN(E);
END;
INTERNAL INTEGER PROCEDURE EXPR$OFF(RPTR(EXPR$)ARRAY ARR; INTEGER I,J);
BEGIN
INTEGER K,K1;
K←1;
FOR K1←I STEP 1 UNTIL J DO IF ARR[K1] THEN K←K+EXPR$:#BODY[ARR[K1]];
RETURN(K);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$R(RPTR(SYMBOL)S);
IF SYMBOL:ACCESS[S]=#ARRAY_ELEMENT THEN
RETURN($APPEND(EXPR$G(S),EXPR$1(XRTVAL),SYMBOL:TYPE[S]))
ELSE
IF SYMBOL:INDEX[S]>0
THEN RETURN($APPEND(EXPR$2(XARTVAL,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN($APPEND(EXPR$2(XGTVAL,SYMBOL:OFFSET[S]),
EXPR$1(XRTVAL),SYMBOL:TYPE[S]))
ELSE RETURN(EXPR$1(XNOOP));
INTERNAL RPTR(EXPR$) PROCEDURE EXPR$G(RPTR(SYMBOL)S);
IF SYMBOL:ACCESS[S]=#ARRAY_ELEMENT THEN
BEGIN
STRING S1; INTEGER I;
INTEGER ARRAY INDEX[1:5]; INTEGER IX;
S1←SYMBOL:PNAME[S];
DO I←LOP(S1) UNTIL I="[";
IX←0;
DO INDEX[IX←IX+1]←INTSCAN(S1,I) UNTIL I="]";
FOR I←IX STEP -1 UNTIL 1 DO BEGIN IPUSH(XPUSHINTI); IPUSH(INDEX[I]); END;
FOR I←XGTVAL,SYMBOL:OFFSET[S] DO IPUSH(I);
RETURN(βEXPR$(SYMBOL:TYPE[S]));
END ELSE
IF SYMBOL:INDEX[S]>0
THEN RETURN($APPEND(EXPR$2(XAGTVAL,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN($APPEND(EXPR$1(XGTVAL),EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE RETURN(EXPR$1(XNOOP));
INTERNAL RPTR (EXPR$) PROCEDURE αEXPR$(INTEGER ARRAY BUFFER;INTEGER #TYPE(0));
BEGIN
! creates a record EXPR$ with data the contents of BUFFER;
RPTR(EXPR$) EE; INTEGER I;
I←ARRINFO(BUFFER,2);
BEGIN
INTEGER ARRAY BUFF[1:I];
ARRTRAN(BUFF,BUFFER);
! EE←NEW_RECORD(EXPR$);
EE←MK_EXPR$;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←I;
END;
EXPR$:TYPE[EE]←#TYPE;
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$ID(RPTR(SYMBOL)S);
IF SYMBOL:ACCESS[S]≠#SIMPLE THEN ERROR("EXPR$ID must take simple argument")
ELSE IF SYMBOL:INDEX[S]>0 THEN
RETURN($APPEND(EXPR$2(XAPUSHOFFSET,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN($APPEND(EXPR$1(XPUSHINTI),EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE RETURN(EXPR$1(XNOOP));
! $append,$aappend;
INTERNAL RPTR(EXPR$) PROCEDURE $APPEND(RPTR(EXPR$)E1,E2; INTEGER TYPE(0));
BEGIN
! produces a new record concatenating the bodies of the E1 and E2;
RPTR(EXPR$)EE; INTEGER J1,J2,J;
IF E1 THEN J1←EXPR$:#BODY[E1] ELSE J1←0;
IF E2 THEN J2←EXPR$:#BODY[E2] ELSE J2←0;
J←J1+J2;
IF J>0 THEN
BEGIN INTEGER ARRAY BUFF[1:J];
IF J1 THEN ARRBLT(BUFF[1],EXPR$:BODY[E1][1],J1);
IF J2 THEN ARRBLT(BUFF[J1+1],EXPR$:BODY[E2][1],J2);
EE←αEXPR$(BUFF,TYPE);
EXPR$:#BODY[EE]←J;
END;
RETURN(EE);
END;
INTERNAL RPTR(EXPR$) PROCEDURE $AAPPEND(RPTR(EXPR$) ARRAY APTR;INTEGER TYPE(0));
BEGIN RPTR(EXPR$) PTR;
INTEGER LA,UA; LA←ARRINFO(APTR,1); UA←ARRINFO(APTR,2);
BEGIN INTEGER I,BSIZE,dsize; INTEGER ARRAY ASIZE,TSIZE[LA:UA];
RPTR(DBEXPR)ARRAY DPTR[LA:UA];
BSIZE←DSIZE←0;
FOR I←LA STEP 1 UNTIL UA DO
IF APTR[I] THEN
BSIZE←BSIZE + (ASIZE[I]←EXPR$:#BODY[APTR[I]]);
IF !DEBUG and ¬!!debugging THEN
FOR I←LA STEP 1 UNTIL UA DO
IF APTR[I] THEN
DSIZE←DSIZE + (TSIZE[I]←
DBEXPR:#COORD[(DPTR[I]←EXPR$:DBEXPR[APTR[I]])]);
IF BSIZE THEN
BEGIN "B"
INTEGER ARRAY BUFF[1:BSIZE]; INTEGER J1;
! PTR←NEW_RECORD(EXPR$);
PTR←MK_EXPR$;
J1←1;
FOR I←LA STEP 1 UNTIL UA DO
IF ASIZE[I]>0 THEN
BEGIN
ARRBLT(BUFF[J1],EXPR$:BODY[APTR[I]][1],ASIZE[I]);
J1←J1+ASIZE[I];
END;
MEMORY[LOCATION(BUFF)] ↔ MEMORY[LOCATION(EXPR$:BODY[PTR])];
EXPR$:#BODY[PTR]←BSIZE;
if !debug and ¬!!debugging and dsize then
begin "D"
integer array txtpos,coord[1:dsize];integer j2;
rptr(blockrec)array block[1:dsize];RPTR(DBEXPR)DBR;
EXPR$:DBEXPR[PTR]←(DBR←NEW_RECORD(DBEXPR));
J2←1;
FOR I←LA STEP 1 UNTIL UA DO
IF TSIZE[I]>0 THEN BEGIN
ARRBLT(TXTPOS[J2],DBEXPR:TXTPOS[DPTR[I]][1],TSIZE[I]);
ARRBLT(COORD[J2],DBEXPR:COORD[DPTR[I]][1],TSIZE[I]);
ARRBLT(BLOCK[J2],DBEXPR:BLOCK[DPTR[I]][1],TSIZE[I]);
J2←J2+TSIZE[I];
end;
MEMORY[LOCATION(txtpos)] ↔ MEMORY[LOCATION(DBEXPR:txtpos[DBR])];
MEMORY[LOCATION(coord)] ↔ MEMORY[LOCATION(DBEXPR:coord[DBR])];
MEMORY[LOCATION(block)] ↔ MEMORY[LOCATION(DBEXPR:block[DBR])];
DBEXPR:#COORD[DBR]←DSIZE;
END "D";
END "B"
ELSE RETURN(NULL_RECORD);
END;
EXPR$:TYPE[PTR]←TYPE;
RETURN(PTR);
END;
! $$gtidref,$$gtanyexp;
! returns code to push offset of id on stack - type must
be the same, else does not return, unless type=0 ;
INTERNAL RPTR(EXPR$) PROCEDURE $$GTIDREF(INTEGER TYPE;
REFERENCE RPTR(SYMBOL)SYM; STRING S);
BEGIN RPTR(EXPR$)E;
E←IDREF(SYM);
IF (TYPE=0) OR (EXPR$:TYPE[E]=TYPE) OR
(TYPE=#FR AND EXPR$:TYPE[E]=#TR) OR
(TYPE=#TR AND EXPR$:TYPE[E]=#FR)
THEN RETURN(E)
ELSE ERROR("Id type found does not agree with expected type in "&S);
END;
! returns an expr of indicated type or doesnt return at all;
INTERNAL RPTR(EXPR$) PROCEDURE $$GTANYEXP(STRING S;INTEGER TYPE);
BEGIN
RPTR(EXPR$)E; INTEGER TYPEF;
TYPEF←EXPR$:TYPE[E←$$GTEXPR];
IF (TYPEF=TYPE) OR (TYPEF=#TR AND TYPE=#FR) OR (TYPEF=#FR AND TYPE=#TR)
THEN RETURN(E)
ELSE IF TYPE≤#RT THEN ERROR("Need "&DTYPES[TYPE]&" expression for ",S)
ELSE ERROR("Need TRANS or FRAME expression for ",S);
END;
INTERNAL REAL PROCEDURE $GTREAL(STRING S);
BEGIN "$GTREAL"
RPTR(!!EXPR)EE;
INTEGER ##ELSAVE,#EL;
##ELSAVE←##EL;
##EL←0;
GGTOKEN;
EE←EXP;
STOKEN←TRUE;
#EL←##EL;
##EL←##ELSAVE;
IF !!EXPR:CONST[EE] THEN RETURN(!!EXPR:RLVAL[EE]) ELSE
ERROR("Need real value for "&S);
END "$GTREAL";
! $$gtexpr,$$gtvexpr;
INTERNAL RPTR(EXPR$) RECURSIVE PROCEDURE $$GTEXPR;
RETURN(GTEXPR);
INTERNAL RECURSIVE RPTR(EXPR$) PROCEDURE $$GTVEXPR;
RETURN($ELFEVAL(GTEXPR));
END "EXPR";